home *** CD-ROM | disk | FTP | other *** search
/ PC Open 107 / PC Open 107 CD 1.bin / CD1 / INTERNET / COPIA SITI / Getleft / getleft-setup-notcl.exe / {app} / scripts / tablelistUtil.tcl < prev    next >
Encoding:
Text File  |  2003-12-28  |  62.8 KB  |  2,163 lines
  1. #==============================================================================
  2. # Contains private utility procedures for tablelist widgets.
  3. #
  4. # Copyright (c) 2000-2004  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
  5. #==============================================================================
  6.  
  7. #------------------------------------------------------------------------------
  8. # tablelist::rowIndex
  9. #
  10. # Checks the row index idx and returns either its numerical value or an error.
  11. # endIsSize must be a boolean value: if true, end refers to the number of items
  12. # in the tablelist, i.e., to the element just after the last one; if false, end
  13. # refers to 1 less than the number of items, i.e., to the last element in the
  14. # tablelist.
  15. #------------------------------------------------------------------------------
  16. proc tablelist::rowIndex {win idx endIsSize} {
  17.     upvar ::tablelist::ns${win}::data data
  18.  
  19.     set idxLen [string length $idx]
  20.     if {[string first $idx active] == 0 && $idxLen >= 2} {
  21.     return $data(activeIdx)
  22.     } elseif {[string first $idx anchor] == 0 && $idxLen >= 2} {
  23.     return $data(anchorIdx)
  24.     } elseif {[string first $idx end] == 0} {
  25.     if {$endIsSize} {
  26.         return $data(itemCount)
  27.     } else {
  28.         return $data(lastRow)
  29.     }
  30.     } elseif {[string compare [string index $idx 0] @] == 0} {
  31.     if {[catch {$data(body) index $idx}] == 0} {
  32.         if {$data(itemCount) == 0} {
  33.         return -1
  34.         } else {
  35.         scan $idx @%d,%d x y
  36.         incr x -[winfo x $data(body)]
  37.         incr y -[winfo y $data(body)]
  38.         set textIdx [$data(body) index @$x,$y]
  39.         return [expr {int($textIdx) - 1}]
  40.         }
  41.     } else {
  42.         return -code error \
  43.            "bad row index \"$idx\": must be active, anchor,\
  44.             end, @x,y, a number, or a full key"
  45.     }
  46.     } elseif {[string compare [string index $idx 0] k] == 0} {
  47.     if {[set index [lsearch $data(itemList) "* $idx"]] >= 0} {
  48.         return $index
  49.     } else {
  50.         return -code error \
  51.            "bad row index \"$idx\": must be active, anchor,\
  52.             end, @x,y, a number, or a full key"
  53.     }
  54.     } elseif {[catch {format %d $idx} index] == 0} {
  55.     return $index
  56.     } else {
  57.     return -code error \
  58.            "bad row index \"$idx\": must be active, anchor,\
  59.             end, @x,y, a number, or a full key"
  60.     }
  61. }
  62.  
  63. #------------------------------------------------------------------------------
  64. # tablelist::colIndex
  65. #
  66. # Checks the column index idx and returns either its numerical value or an
  67. # error.  checkRange must be a boolean value: if true, it is additionally
  68. # checked whether the numerical value corresponding to idx is within the
  69. # allowed range.
  70. #------------------------------------------------------------------------------
  71. proc tablelist::colIndex {win idx checkRange} {
  72.     upvar ::tablelist::ns${win}::data data
  73.  
  74.     if {[string first $idx end] == 0} {
  75.     return $data(lastCol)
  76.     } elseif {[string compare [string index $idx 0] @] == 0 &&
  77.           [catch {$data(body) index $idx}] == 0} {
  78.     scan $idx @%d x
  79.     incr x -[winfo x $data(body)]
  80.     set bodyWidth [winfo width $data(body)]
  81.     if {$x >= $bodyWidth} {
  82.         set x [expr {$bodyWidth - 1}]
  83.     } elseif {$x < 0} {
  84.         set x 0
  85.     }
  86.     set x [expr {$x + [winfo rootx $data(body)]}]
  87.  
  88.     set lastVisibleCol -1
  89.     for {set col 0} {$col < $data(colCount)} {incr col} {
  90.         if {$data($col-hide)} {
  91.         continue
  92.         }
  93.  
  94.         set lastVisibleCol $col
  95.         set w $data(hdrTxtFrLbl)$col
  96.         set wX [winfo rootx $w]
  97.         if {$x >= $wX && $x < $wX + [winfo width $w]} {
  98.         return $col
  99.         }
  100.     }
  101.     set index $lastVisibleCol
  102.     } elseif {[catch {format %d $idx} index] != 0} {
  103.     for {set col 0} {$col < $data(colCount)} {incr col} {
  104.         set hasName [info exists data($col-name)]
  105.         if {$hasName && [string compare $idx $data($col-name)] == 0 ||
  106.         !$hasName && [string compare $idx ""] == 0} {
  107.         set index $col
  108.         break
  109.         }
  110.     }
  111.     if {$col == $data(colCount)} {
  112.         return -code error \
  113.            "bad column index \"$idx\": must be\
  114.             end, @x,y, a number, or a name"
  115.     }
  116.     }
  117.  
  118.     if {$checkRange && ($index < 0 || $index > $data(lastCol))} {
  119.     return -code error "column index \"$idx\" out of range"
  120.     } else {
  121.     return $index
  122.     }
  123. }
  124.  
  125. #------------------------------------------------------------------------------
  126. # tablelist::cellIndex
  127. #
  128. # Checks the cell index idx and returns either its value in the form row,col or
  129. # an error.  checkRange must be a boolean value: if true, it is additionally
  130. # checked whether the two numerical values corresponding to idx are within the
  131. # respective allowed ranges.
  132. #------------------------------------------------------------------------------
  133. proc tablelist::cellIndex {win idx checkRange} {
  134.     upvar ::tablelist::ns${win}::data data
  135.  
  136.     if {[string first $idx end] == 0} {
  137.     set row [rowIndex $win $idx 0]
  138.     set col [colIndex $win $idx 0]
  139.     } elseif {[string compare [string index $idx 0] @] == 0} {
  140.     if {[catch {rowIndex $win $idx 0} row] != 0 ||
  141.         [catch {colIndex $win $idx 0} col] != 0} {
  142.         return -code error \
  143.            "bad cell index \"$idx\": must be end, @x,y, or row,col,\
  144.             where row must be active, anchor, end, a number, or\
  145.             a full key, and col must be end, a number, or a name"
  146.     }
  147.     } else {
  148.     set lst [split $idx ,]
  149.     if {[llength $lst] != 2 ||
  150.         [catch {rowIndex $win [lindex $lst 0] 0} row] != 0 ||
  151.         [catch {colIndex $win [lindex $lst 1] 0} col] != 0} {
  152.         return -code error \
  153.            "bad cell index \"$idx\": must be end, @x,y, or row,col,\
  154.             where row must be active, anchor, end, a number, or\
  155.             a full key, and col must be end, a number, or a name"
  156.     }
  157.     }
  158.  
  159.     if {$checkRange && ($row < 0 || $row > $data(lastRow) || \
  160.     $col < 0 || $col > $data(lastCol))} {
  161.     return -code error "cell index \"$idx\" out of range"
  162.     } else {
  163.     return $row,$col
  164.     }
  165. }
  166.  
  167. #------------------------------------------------------------------------------
  168. # tablelist::findCellTabs
  169. #
  170. # Searches for the tab characters within the col'th cell in the given line of
  171. # the body text child of the tablelist widget win.  Assigns the index of the
  172. # first tab to $idx1Name and the index of the second tab to $idx2Name.
  173. #------------------------------------------------------------------------------
  174. proc tablelist::findCellTabs {win line col idx1Name idx2Name} {
  175.     upvar ::tablelist::ns${win}::data data
  176.     upvar $idx1Name idx1 $idx2Name idx2
  177.  
  178.     set w $data(body)
  179.     set idx1 $line.0
  180.     set endIdx $line.end
  181.     for {set n 0} {$n < $col} {incr n} {
  182.     if {!$data($n-hide)} {
  183.         set idx1 [$w search \t $idx1+1c $endIdx]+1c
  184.     }
  185.     }
  186.     set idx1 [$w index $idx1]
  187.     set idx2 [$w search \t $idx1+1c $endIdx]
  188.  
  189.     return ""
  190. }
  191.  
  192. #------------------------------------------------------------------------------
  193. # tablelist::cellFont
  194. #
  195. # Returns the font to be used in the tablelist cell specified by win, key, and
  196. # col.
  197. #------------------------------------------------------------------------------
  198. proc tablelist::cellFont {win key col} {
  199.     upvar ::tablelist::ns${win}::data data
  200.  
  201.     if {[info exists data($key-$col-font)]} {
  202.     return $data($key-$col-font)
  203.     } elseif {[info exists data($key-font)]} {
  204.     return $data($key-font)
  205.     } else {
  206.     return [lindex $data(colFontList) $col]
  207.     }
  208. }
  209.  
  210. #------------------------------------------------------------------------------
  211. # tablelist::sortStretchableColList
  212. #
  213. # Replaces the column indices different from end in the list of the stretchable
  214. # columns of the tablelist widget win with their numerical equivalents and
  215. # sorts the resulting list.
  216. #------------------------------------------------------------------------------
  217. proc tablelist::sortStretchableColList win {
  218.     upvar ::tablelist::ns${win}::data data
  219.  
  220.     if {[llength $data(-stretch)] == 0 ||
  221.     [string first $data(-stretch) all] == 0} {
  222.     return ""
  223.     }
  224.  
  225.     set containsEnd 0
  226.     foreach elem $data(-stretch) {
  227.     if {[string first $elem end] == 0} {
  228.         set containsEnd 1
  229.     } else {
  230.         set tmp([colIndex $win $elem 0]) ""
  231.     }
  232.     }
  233.  
  234.     set data(-stretch) [lsort -integer [array names tmp]]
  235.     if {$containsEnd} {
  236.     lappend data(-stretch) end
  237.     }
  238. }
  239.  
  240. #------------------------------------------------------------------------------
  241. # tablelist::deleteColData
  242. #
  243. # Cleans up the data associated with the col'th column of the tablelist widget
  244. # win.
  245. #------------------------------------------------------------------------------
  246. proc tablelist::deleteColData {win col} {
  247.     upvar ::tablelist::ns${win}::data data
  248.  
  249.     if {$data(editCol) == $col} {
  250.     set data(editCol) -1
  251.     set data(editRow) -1
  252.     }
  253.     if {$data(arrowCol) == $col} {
  254.     set data(arrowCol) -1
  255.     }
  256.     if {$data(sortCol) == $col} {
  257.     set data(sortCol) -1
  258.     }
  259.  
  260.     #
  261.     # Remove the elements with names of the form $col-*
  262.     #
  263.     set w $data(body)
  264.     foreach name [array names data $col-*] {
  265.     unset data($name)
  266.     $w tag delete $name
  267.     }
  268.  
  269.     #
  270.     # Remove the elements with names of the form k*-$col-*
  271.     #
  272.     foreach name [array names data k*-$col-*] {
  273.     unset data($name)
  274.     $w tag delete $name
  275.     if {[string match k*-$col-\[bf\]* $name]} {
  276.         incr data(tagCount) -1
  277.     } elseif {[string match k*-$col-image $name]} {
  278.         incr data(imgCount) -1
  279.     }
  280.     }
  281.  
  282.     #
  283.     # Remove col from the list of stretchable columns if explicitly specified
  284.     #
  285.     if {[string first $data(-stretch) all] != 0} {
  286.     set stretchableCols {}
  287.     foreach elem $data(-stretch) {
  288.         if {[string first $elem end] == 0 || $elem != $col} {
  289.         lappend stretchableCols $elem
  290.         }
  291.     }
  292.     set data(-stretch) $stretchableCols
  293.     }
  294. }
  295.  
  296. #------------------------------------------------------------------------------
  297. # tablelist::moveColData
  298. #
  299. # Moves the elements of oldArrName corresponding to oldCol to those of
  300. # newArrName corresponding to newCol.
  301. #------------------------------------------------------------------------------
  302. proc tablelist::moveColData {win oldArrName newArrName imgArrName
  303.                  oldCol newCol} {
  304.     upvar $oldArrName oldArr $newArrName newArr $imgArrName imgArr
  305.  
  306.     #
  307.     # Move the elements of oldArr with names of the form $oldCol-*
  308.     # to those of newArr with names of the form $newCol-*
  309.     #
  310.     set w $newArr(body)
  311.     foreach newName [array names newArr $newCol-*] {
  312.     unset newArr($newName)
  313.     $w tag delete $newName
  314.     }
  315.     if {$newCol < $newArr(colCount)} {
  316.     foreach c [winfo children $newArr(hdrTxtFrLbl)$newCol] {
  317.         destroy $c
  318.     }
  319.     set newArr(fmtCmdFlagList) \
  320.         [lreplace $newArr(fmtCmdFlagList) $newCol $newCol 0]
  321.     }
  322.     if {$oldArr(editCol) == $oldCol} {
  323.     set newArr(editCol) $newCol
  324.     }
  325.     if {$oldArr(arrowCol) == $oldCol} {
  326.     set newArr(arrowCol) $newCol
  327.     }
  328.     if {$oldArr(sortCol) == $oldCol} {
  329.     set newArr(sortCol) $newCol
  330.     }
  331.     foreach oldName [array names oldArr $oldCol-*] {
  332.     regsub $oldCol- $oldName $newCol- newName
  333.     set newArr($newName) $oldArr($oldName)
  334.  
  335.     unset oldArr($oldName)
  336.     $w tag delete $oldName
  337.  
  338.     set tail [lindex [split $newName -] 1]
  339.     switch $tail {
  340.         background -
  341.         foreground {
  342.         $w tag configure $newName -$tail $newArr($newName)
  343.         $w tag raise $newName stripe
  344.         }
  345.         font {
  346.         $w tag configure $newName -$tail $newArr($newName)
  347.         $w tag lower $newName
  348.         }
  349.         formatcommand {
  350.         if {$newCol < $newArr(colCount)} {
  351.             set newArr(fmtCmdFlagList) \
  352.             [lreplace $newArr(fmtCmdFlagList) $newCol $newCol 1]
  353.         }
  354.         }
  355.         labelimage {
  356.         set imgArr($newCol-$tail) $newArr($newName)
  357.         unset newArr($newName)
  358.         }
  359.         selectbackground -
  360.         selectforeground {
  361.         set tail [string range $tail 6 end]    ;# remove the select
  362.         $w tag configure $newName -$tail $newArr($newName)
  363.         $w tag raise $newName select
  364.         }
  365.     }
  366.     }
  367.  
  368.     #
  369.     # Move the elements of oldArr with names of the form k*-$oldCol-*
  370.     # to those of newArr with names of the form k*-$newCol-*
  371.     #
  372.     foreach newName [array names newArr k*-$newCol-*] {
  373.     unset newArr($newName)
  374.     $w tag delete $newName
  375.     }
  376.     foreach oldName [array names oldArr k*-$oldCol-*] {
  377.     regsub -- -$oldCol- $oldName -$newCol- newName
  378.     set newArr($newName) $oldArr($oldName)
  379.  
  380.     unset oldArr($oldName)
  381.     $w tag delete $oldName
  382.  
  383.     set tail [lindex [split $newName -] 2]
  384.     switch $tail {
  385.         background -
  386.         foreground {
  387.         $w tag configure $newName -$tail $newArr($newName)
  388.         $w tag lower $newName disabled
  389.         }
  390.         font {
  391.         $w tag configure $newName -$tail $newArr($newName)
  392.         $w tag raise $newName
  393.         }
  394.         selectbackground -
  395.         selectforeground {
  396.         set tail [string range $tail 6 end]    ;# remove the select
  397.         $w tag configure $newName -$tail $newArr($newName)
  398.         $w tag lower $newName disabled
  399.         }
  400.     }
  401.     }
  402.  
  403.     #
  404.     # Replace oldCol with newCol in the list of
  405.     # stretchable columns if explicitly specified
  406.     #
  407.     if {[info exists oldArr(-stretch)] &&
  408.     [string first $oldArr(-stretch) all] != 0} {
  409.     set stretchableCols {}
  410.     foreach elem $oldArr(-stretch) {
  411.         if {[string first $elem end] != 0 && $elem == $oldCol} {
  412.         lappend stretchableCols $newCol
  413.         } else {
  414.         lappend stretchableCols $elem
  415.         }
  416.     }
  417.     set newArr(-stretch) $stretchableCols
  418.     }
  419. }
  420.  
  421. #------------------------------------------------------------------------------
  422. # tablelist::condUpdateListVar
  423. #
  424. # Updates the list variable of the tablelist widget win if present.
  425. #------------------------------------------------------------------------------
  426. proc tablelist::condUpdateListVar win {
  427.     upvar ::tablelist::ns${win}::data data
  428.  
  429.     if {$data(hasListVar)} {
  430.     trace vdelete ::$data(-listvariable) wu $data(listVarTraceCmd)
  431.     upvar #0 $data(-listvariable) var
  432.     set var {}
  433.     foreach item $data(itemList) {
  434.         lappend var [lrange $item 0 $data(lastCol)]
  435.     }
  436.     trace variable ::$data(-listvariable) wu $data(listVarTraceCmd)
  437.     }
  438. }
  439.  
  440. #------------------------------------------------------------------------------
  441. # tablelist::reconfigColLabels
  442. #
  443. # Reconfigures the labels of the col'th column of the tablelist widget win.
  444. #------------------------------------------------------------------------------
  445. proc tablelist::reconfigColLabels {win imgArrName col} {
  446.     upvar ::tablelist::ns${win}::data data
  447.     upvar $imgArrName imgArr
  448.  
  449.     foreach opt {-labelalign -labelbackground -labelborderwidth -labelfont
  450.          -labelforeground -labelheight -labelpady -labelrelief} {
  451.     if {[info exists data($col$opt)]} {
  452.         doColConfig $col $win $opt $data($col$opt)
  453.     } else {
  454.         doColConfig $col $win $opt ""
  455.     }
  456.     }
  457.  
  458.     if {[info exists imgArr($col-labelimage)]} {
  459.     doColConfig $col $win -labelimage $imgArr($col-labelimage)
  460.     }
  461. }
  462.  
  463. #------------------------------------------------------------------------------
  464. # tablelist::charsToPixels
  465. #
  466. # Returns the width in pixels of the string consisting of a given number of "0"
  467. # characters.
  468. #------------------------------------------------------------------------------
  469. proc tablelist::charsToPixels {win font charCount} {
  470.     ### set str [string repeat 0 $charCount]
  471.     set str ""
  472.     for {set n 0} {$n < $charCount} {incr n} {
  473.     append str 0
  474.     }
  475.     return [font measure $font -displayof $win $str]
  476. }
  477.  
  478. #------------------------------------------------------------------------------
  479. # tablelist::strRange
  480. #
  481. # Returns the largest initial (for alignment = left or center) or final (for
  482. # alignment = right) range of characters from str whose width, when displayed
  483. # in the given font, is no greater than pixels.
  484. #------------------------------------------------------------------------------
  485. proc tablelist::strRange {win str font pixels alignment} {
  486.     if {[font measure $font -displayof $win $str] <= $pixels} {
  487.     return $str
  488.     }
  489.  
  490.     set halfLen [expr {[string length $str] / 2}]
  491.     if {$halfLen == 0} {
  492.     return ""
  493.     }
  494.  
  495.     if {[string compare $alignment right] == 0} {
  496.     set rightStr [string range $str $halfLen end]
  497.     set width [font measure $font -displayof $win $rightStr]
  498.     if {$width == $pixels} {
  499.         return $rightStr
  500.     } elseif {$width > $pixels} {
  501.         return [strRange $win $rightStr $font $pixels $alignment]
  502.     } else {
  503.         set str [string range $str 0 [expr {$halfLen - 1}]]
  504.         return [strRange $win $str $font \
  505.             [expr {$pixels - $width}] $alignment]$rightStr
  506.     }
  507.     } else {
  508.     set leftStr [string range $str 0 [expr {$halfLen - 1}]]
  509.     set width [font measure $font -displayof $win $leftStr]
  510.     if {$width == $pixels} {
  511.         return $leftStr
  512.     } elseif {$width > $pixels} {
  513.         return [strRange $win $leftStr $font $pixels $alignment]
  514.     } else {
  515.         set str [string range $str $halfLen end]
  516.         return $leftStr[strRange $win $str $font \
  517.                 [expr {$pixels - $width}] $alignment]
  518.     }
  519.     }
  520. }
  521.  
  522. #------------------------------------------------------------------------------
  523. # tablelist::strRangeExt
  524. #
  525. # Invokes strRange with the given arguments and returns a string obtained by
  526. # appending (for alignment = left or center) or prepending (for alignment =
  527. # right) (part of) the snip string to (part of) its result.
  528. #------------------------------------------------------------------------------
  529. proc tablelist::strRangeExt {win str font pixels alignment snipStr} {
  530.     set subStr [strRange $win $str $font $pixels $alignment]
  531.     set len [string length $subStr]
  532.     if {$pixels < 0 || $len == [string length $str] ||
  533.     [string compare $snipStr ""] == 0} {
  534.     return $subStr
  535.     }
  536.  
  537.     if {[string compare $alignment right] == 0} {
  538.     set extSubStr $snipStr$subStr
  539.     while {[font measure $font -displayof $win $extSubStr] > $pixels} {
  540.         if {$len > 0} {
  541.         set subStr [string range $subStr 1 end]
  542.         incr len -1
  543.         set extSubStr $snipStr$subStr
  544.         } else {
  545.         set extSubStr [string range $extSubStr 1 end]
  546.         }
  547.     }
  548.     } else {
  549.     set last [expr {$len - 1}]
  550.     set extSubStr $subStr$snipStr
  551.     while {[font measure $font -displayof $win $extSubStr] > $pixels} {
  552.         if {$last >= 0} {
  553.         incr last -1
  554.         set subStr [string range $subStr 0 $last]
  555.         set extSubStr $subStr$snipStr
  556.         } else {
  557.         set extSubStr [string range $extSubStr 1 end]
  558.         }
  559.     }
  560.     }
  561.  
  562.     return $extSubStr
  563. }
  564.  
  565. #------------------------------------------------------------------------------
  566. # tablelist::adjustItem
  567. #
  568. # Returns the list obtained by adjusting the list specified by item to the
  569. # length expLen.
  570. #------------------------------------------------------------------------------
  571. proc tablelist::adjustItem {item expLen} {
  572.     set len [llength $item]
  573.     if {$len < $expLen} {
  574.     for {set n $len} {$n < $expLen} {incr n} {
  575.         lappend item ""
  576.     }
  577.     return $item
  578.     } else {
  579.     return [lrange $item 0 [expr {$expLen - 1}]]
  580.     }
  581. }
  582.  
  583. #------------------------------------------------------------------------------
  584. # tablelist::adjustElem
  585. #
  586. # Prepares the text specified by $textName and the image width specified by
  587. # $imageWidthName for insertion into a cell of the tablelist widget win.
  588. #------------------------------------------------------------------------------
  589. proc tablelist::adjustElem {win textName imageWidthName font
  590.                 pixels alignment snipStr} {
  591.     upvar $textName text $imageWidthName imageWidth
  592.  
  593.     if {$pixels == 0} {                ;# convention: dynamic width
  594.     if {$imageWidth != 0 && [string compare $text ""] != 0} {
  595.         if {[string compare $alignment right] == 0} {
  596.         set text "$text "
  597.         } else {
  598.         set text " $text"
  599.         }
  600.     }
  601.     } elseif {$imageWidth == 0} {        ;# no image
  602.     set text [strRangeExt $win $text $font $pixels $alignment $snipStr]
  603.     } elseif {[string compare $text ""] == 0} {    ;# image w/o text
  604.     if {$imageWidth > $pixels} {
  605.         set imageWidth 0            ;# can't display the image
  606.     }
  607.     } else {                    ;# both image and text
  608.     set gap [font measure $font -displayof $win " "]
  609.     if {$imageWidth + $gap <= $pixels} {
  610.         incr pixels -[expr {$imageWidth + $gap}]
  611.         set text [strRangeExt $win $text $font $pixels $alignment $snipStr]
  612.         if {[string compare $alignment right] == 0} {
  613.         set text "$text "
  614.         } else {
  615.         set text " $text"
  616.         }
  617.     } elseif {$imageWidth <= $pixels} {
  618.         set text ""                ;# can't display the text
  619.     } else {
  620.         set imageWidth 0            ;# can't display the image
  621.         set text ""                ;# can't display the text
  622.     }
  623.     }
  624. }
  625.  
  626. #------------------------------------------------------------------------------
  627. # tablelist::insertElem
  628. #
  629. # Inserts the given text and image into the text widget w, just before the
  630. # character position specified by index.  The image will follow the text if
  631. # alignment is "right", and will precede it otherwise.
  632. #------------------------------------------------------------------------------
  633. proc tablelist::insertElem {w index text image imageWidth alignment} {
  634.     set index [$w index $index]
  635.  
  636.     if {$imageWidth == 0} {
  637.     $w insert $index $text
  638.     } elseif {[string compare $alignment right] == 0} {
  639.     $w image create $index -image $image
  640.     $w insert $index $text
  641.     } else {
  642.     $w insert $index $text
  643.     $w image create $index -image $image
  644.     }
  645. }
  646.  
  647. #------------------------------------------------------------------------------
  648. # tablelist::isCharVisible
  649. #
  650. # Checks whether the given text widget character is visible.  It is assumed
  651. # that the line containing the character is visible.
  652. #------------------------------------------------------------------------------
  653. proc tablelist::isCharVisible {w textIdx} {
  654.     set lineEnd [$w index "$textIdx lineend"]
  655.     if {[string compare $textIdx $lineEnd] == 0} {
  656.     return [expr {[lindex [$w xview] 1] == 1.0}]
  657.     } else {
  658.     return [expr {[string compare [$w bbox $textIdx] ""] != 0}]
  659.     }
  660. }
  661.  
  662. #------------------------------------------------------------------------------
  663. # tablelist::makeColFontAndTagLists
  664. #
  665. # Builds the lists data(colFontList) of the column fonts and data(colTagsList)
  666. # of the column tag names.
  667. #------------------------------------------------------------------------------
  668. proc tablelist::makeColFontAndTagLists win {
  669.     upvar ::tablelist::ns${win}::data data
  670.  
  671.     set widgetFont $data(-font)
  672.     set data(colFontList) {}
  673.     set data(colTagsList) {}
  674.     set data(hasColTags) 0
  675.  
  676.     for {set col 0} {$col < $data(colCount)} {incr col} {
  677.     set tagNames {}
  678.  
  679.     if {[info exists data($col-font)]} {
  680.         lappend data(colFontList) $data($col-font)
  681.         lappend tagNames $col-font
  682.         set data(hasColTags) 1
  683.     } else {
  684.         lappend data(colFontList) $widgetFont
  685.     }
  686.  
  687.     foreach opt {-background -foreground} {
  688.         if {[info exists data($col$opt)]} {
  689.         lappend tagNames $col$opt
  690.         set data(hasColTags) 1
  691.         }
  692.     }
  693.  
  694.     lappend data(colTagsList) $tagNames
  695.     }
  696. }
  697.  
  698. #------------------------------------------------------------------------------
  699. # tablelist::setupColumns
  700. #
  701. # Updates the value of the -colums configuration option for the tablelist
  702. # widget win by using the width, title, and alignment specifications given in
  703. # the columns argument, and creates the corresponding label (and separator)
  704. # widgets if createLabels is true.
  705. #------------------------------------------------------------------------------
  706. proc tablelist::setupColumns {win columns createLabels} {
  707.     variable configSpecs
  708.     variable configOpts
  709.     variable alignments
  710.     upvar ::tablelist::ns${win}::data data
  711.  
  712.     set argCount [llength $columns]
  713.     set colConfigVals {}
  714.  
  715.     #
  716.     # Check the syntax of columns before performing any changes
  717.     #
  718.     for {set n 0} {$n < $argCount} {incr n} {
  719.     #
  720.     # Get the column width
  721.     #
  722.     set width [lindex $columns $n]
  723.     set width [format %d $width]    ;# integer check with error message
  724.  
  725.     #
  726.     # Get the column title
  727.     #
  728.     if {[incr n] == $argCount} {
  729.         return -code error "column title missing"
  730.     }
  731.     set title [lindex $columns $n]
  732.  
  733.     #
  734.     # Get the column alignment
  735.     #
  736.     set alignment left
  737.     if {[incr n] < $argCount} {
  738.         set next [lindex $columns $n]
  739.         if {[catch {format %d $next}] == 0} {    ;# integer check
  740.         incr n -1
  741.         } else {
  742.         set alignment [mwutil::fullOpt "alignment" $next $alignments]
  743.         }
  744.     }
  745.  
  746.     #
  747.     # Append the properly formatted values of width,
  748.     # title, and alignment to the list colConfigVals
  749.     #
  750.     lappend colConfigVals $width $title $alignment
  751.     }
  752.  
  753.     #
  754.     # Save the value of colConfigVals in data(-columns)
  755.     #
  756.     set data(-columns) $colConfigVals
  757.  
  758.     #
  759.     # Delete the labels and separators if requested
  760.     #
  761.     if {$createLabels} {
  762.     set children [winfo children $data(hdrTxtFr)]
  763.     foreach w [lrange [lsort $children] 1 end] {
  764.         destroy $w
  765.     }
  766.     foreach w [winfo children $win] {
  767.         if {[regexp {^sep[0-9]+$} [winfo name $w]]} {
  768.         destroy $w
  769.         }
  770.     }
  771.     set data(fmtCmdFlagList) {}
  772.     }
  773.  
  774.     #
  775.     # Build the list data(colList), and create the labels if requested
  776.     #
  777.     set widgetFont $data(-font)
  778.     set data(colList) {}
  779.     set col 0
  780.     foreach {width title alignment} $data(-columns) {
  781.     #
  782.     # Append the width in pixels and the
  783.     # alignment to the list data(colList)
  784.     #
  785.     if {$width > 0} {        ;# convention: width in characters
  786.         set pixels [charsToPixels $win $widgetFont $width]
  787.         set data($col-lastStaticWidth) $pixels
  788.     } elseif {$width < 0} {        ;# convention: width in pixels
  789.         set pixels [expr {(-1)*$width}]
  790.         set data($col-lastStaticWidth) $pixels
  791.     } else {            ;# convention: dynamic width
  792.         set pixels 0
  793.     }
  794.     lappend data(colList) $pixels $alignment
  795.  
  796.     if {$createLabels} {
  797.         foreach {name val} {delta 0  lastStaticWidth 0  maxPixels 0
  798.                 editable 0  editwindow entry  hide 0
  799.                 maxwidth 0  resizable 1  showarrow 1
  800.                 sortmode ascii} {
  801.         if {![info exists data($col-$name)]} {
  802.             set data($col-$name) $val
  803.         }
  804.         }
  805.         lappend data(fmtCmdFlagList) [info exists data($col-formatcommand)]
  806.  
  807.         #
  808.         # Create the label
  809.         #
  810.         set w $data(hdrTxtFrLbl)$col
  811.         label $w -bitmap "" -highlightthickness 0 -image "" -takefocus 0 \
  812.              -text "" -textvariable "" -underline -1 -wraplength 0
  813.  
  814.         #
  815.         # Apply to it the current configuration options
  816.         #
  817.         foreach opt $configOpts {
  818.         set optGrp [lindex $configSpecs($opt) 2]
  819.         if {[string compare $optGrp l] == 0} {
  820.             set optTail [string range $opt 6 end]
  821.             if {[info exists data($col$opt)]} {
  822.             $w configure -$optTail $data($col$opt)
  823.             } else {
  824.             $w configure -$optTail $data($opt)
  825.             }
  826.         } elseif {[string compare $optGrp c] == 0} {
  827.             $w configure $opt $data($opt)
  828.         }
  829.         }
  830.         catch {$w configure -state $data(-state)}
  831.  
  832.         #
  833.         # Replace the binding tag Label with TablelistLabel
  834.         # in the list of binding tags of the label
  835.         #
  836.         bindtags $w [lreplace [bindtags $w] 1 1 TablelistLabel]
  837.  
  838.         if {[info exists data($col-labelimage)]} {
  839.         doColConfig $col $win -labelimage $data($col-labelimage)
  840.         }
  841.     }
  842.  
  843.     #
  844.     # Configure the edit window if present
  845.     #
  846.     if {$col == $data(editCol)} {
  847.         if {[string compare [winfo class $data(bodyFrEd)] Mentry] != 0} {
  848.         catch {$data(bodyFrEd) configure -justify $alignment}
  849.         }
  850.     }
  851.  
  852.     incr col
  853.     }
  854.  
  855.     #
  856.     # Save the number of columns in data(colCount)
  857.     #
  858.     set oldColCount $data(colCount)
  859.     set data(colCount) $col
  860.     set data(lastCol) [expr {$col - 1}]
  861.  
  862.     #
  863.     # Clean up the data associated with the deleted columns
  864.     #
  865.     for {set col $data(colCount)} {$col < $oldColCount} {incr col} {
  866.     deleteColData $win $col
  867.     }
  868.  
  869.     #
  870.     # Create the separators if needed
  871.     #
  872.     if {$createLabels && $data(-showseparators)} {
  873.     createSeps $win
  874.     }
  875. }
  876.  
  877. #------------------------------------------------------------------------------
  878. # tablelist::createSeps
  879. #
  880. # Creates and manages the separator frames in the tablelist widget win.
  881. #------------------------------------------------------------------------------
  882. proc tablelist::createSeps win {
  883.     upvar ::tablelist::ns${win}::data data
  884.  
  885.     for {set col 0} {$col < $data(colCount)} {incr col} {
  886.     #
  887.     # Create the col'th separator frame and attach it
  888.     # to the right edge of the col'th header label
  889.     #
  890.     set w $data(sep)$col
  891.     frame $w -background $data(-background) -borderwidth 1 -container 0 \
  892.          -highlightthickness 0 -relief raised -takefocus 0 -width 2
  893.     place $w -in $data(hdrTxtFrLbl)$col -anchor ne -bordermode outside \
  894.          -relx 1.0
  895.  
  896.     #
  897.     # Replace the binding tag Frame with TablelistBody
  898.     # in the list of binding tags of the separator frame
  899.     #
  900.     bindtags $w [lreplace [bindtags $w] 1 1 TablelistBody]
  901.     }
  902.     
  903.     adjustSepsWhenIdle $win
  904. }
  905.  
  906. #------------------------------------------------------------------------------
  907. # tablelist::adjustSepsWhenIdle
  908. #
  909. # Arranges for the height and vertical position of each separator frame in the
  910. # tablelist widget win to be adjusted at idle time.
  911. #------------------------------------------------------------------------------
  912. proc tablelist::adjustSepsWhenIdle win {
  913.     upvar ::tablelist::ns${win}::data data
  914.  
  915.     if {[info exists data(sepsId)]} {
  916.     return ""
  917.     }
  918.  
  919.     set data(sepsId) [after idle [list tablelist::adjustSeps $win]]
  920. }
  921.  
  922. #------------------------------------------------------------------------------
  923. # tablelist::adjustSeps
  924. #
  925. # Adjusts the height and vertical position of each separator frame in the
  926. # tablelist widget win.
  927. #------------------------------------------------------------------------------
  928. proc tablelist::adjustSeps win {
  929.     upvar ::tablelist::ns${win}::data data
  930.  
  931.     if {[info exists data(sepsId)]} {
  932.     after cancel $data(sepsId)
  933.     unset data(sepsId)
  934.     }
  935.  
  936.     #
  937.     # Get the height to be applied to the separator frames
  938.     #
  939.     set w $data(body)
  940.     set textIdx [$w index @0,[winfo height $w]]
  941.     set dlineinfo [$w dlineinfo $textIdx]
  942.     if {$data(itemCount) == 0 || [string compare $dlineinfo ""] == 0} {
  943.     set sepHeight 1
  944.     } else {
  945.     foreach {x y width height baselinePos} $dlineinfo {
  946.         set sepHeight [expr {$y + $height}]
  947.     }
  948.     }
  949.  
  950.     #
  951.     # Set the height and vertical position of each separator frame
  952.     #
  953.     foreach w [winfo children $win] {
  954.     if {[regexp {^sep[0-9]+$} [winfo name $w]]} {
  955.         $w configure -height $sepHeight
  956.         if {$data(-showlabels)} {
  957.         place configure $w -rely 1.0 -y 0
  958.         } else {
  959.         place configure $w -rely 0.0 -y 1
  960.         }
  961.     }
  962.     }
  963. }
  964.  
  965. #------------------------------------------------------------------------------
  966. # tablelist::adjustColumns
  967. #
  968. # Applies some configuration options to the labels of the tablelist widget win,
  969. # places them in the header frame, computes and sets the tab stops for the body
  970. # text widget, and adjusts the width and height of the header frame.  The
  971. # whichWidths argument specifies the dynamic-width columns or labels whose
  972. # widths are to be computed when performing these operations.  The stretchCols
  973. # argument specifies whether to stretch the stretchable columns.
  974. #------------------------------------------------------------------------------
  975. proc tablelist::adjustColumns {win whichWidths stretchCols} {
  976.     upvar ::tablelist::ns${win}::data data
  977.  
  978.     set compAllColWidths [expr {[string compare $whichWidths allCols] == 0}]
  979.     set compAllLabelWidths [expr {[string compare $whichWidths allLabels] == 0}]
  980.  
  981.     #
  982.     # Configure the labels, place them in the header frame, and compute
  983.     # the positions of the tab stops to be set in the body text widget
  984.     #
  985.     set data(hdrPixels) 0
  986.     set tabs {}
  987.     set col 0
  988.     set x 0
  989.     foreach {pixels alignment} $data(colList) {
  990.     set w $data(hdrTxtFrLbl)$col
  991.     if {$data($col-hide)} {
  992.         place forget $w
  993.         incr col
  994.         continue
  995.     }
  996.  
  997.     #
  998.     # Adjust the col'th label
  999.     #
  1000.     if {$pixels != 0} {            ;# convention: static width
  1001.         incr pixels $data($col-delta)
  1002.     }
  1003.     if {[info exists data($col-labelalign)]} {
  1004.         set labelAlignment $data($col-labelalign)
  1005.     } else {
  1006.         set labelAlignment $alignment
  1007.     }
  1008.     adjustLabel $win $col $pixels $labelAlignment
  1009.  
  1010.     if {$pixels == 0} {            ;# convention: dynamic width
  1011.         #
  1012.         # Compute the column or label width if requested
  1013.         #
  1014.         if {$compAllColWidths} {
  1015.         computeColWidth $win $col
  1016.         } elseif {$compAllLabelWidths} {
  1017.         computeLabelWidth $win $col
  1018.         } elseif {[lsearch -exact $whichWidths $col] >= 0} {
  1019.         computeColWidth $win $col
  1020.         } elseif {[lsearch -exact $whichWidths l$col] >= 0} {
  1021.         computeLabelWidth $win $col
  1022.         }
  1023.  
  1024.         set pixels $data($col-reqPixels)
  1025.         if {$data($col-maxPixels) > 0 && $pixels > $data($col-maxPixels)} {
  1026.         set pixels $data($col-maxPixels)
  1027.         incr pixels $data($col-delta)
  1028.         adjustLabel $win $col $pixels $labelAlignment
  1029.         } else {
  1030.         incr pixels $data($col-delta)
  1031.         }
  1032.     }
  1033.  
  1034.     if {$col == $data(editCol)} {
  1035.         adjustEditWindow $win $pixels
  1036.     }
  1037.  
  1038.     if {$col == $data(arrowCol)} {
  1039.         #
  1040.         # Place the canvas to the left side of the label if the
  1041.         # latter is right-justified and to its right side otherwise
  1042.         #
  1043.         set canvas $data(hdrTxtFrCanv)
  1044.         if {[string compare $labelAlignment right] == 0} {
  1045.         place $canvas -in $w -anchor w -bordermode outside \
  1046.                   -relx 0.0 -x $data(charWidth) -rely 0.5
  1047.         } else {
  1048.         place $canvas -in $w -anchor e -bordermode outside \
  1049.                   -relx 1.0 -x -$data(charWidth) -rely 0.5
  1050.         }
  1051.         raise $canvas
  1052.     }
  1053.  
  1054.     #
  1055.     # Place the label in the header frame
  1056.     #
  1057.     set labelPixels [expr {$pixels + 2*$data(charWidth)}]
  1058.     place $w -x $x -relheight 1.0 -width $labelPixels
  1059.     incr x $labelPixels
  1060.  
  1061.     #
  1062.     # Append a tab stop and the alignment to the tabs list
  1063.     #
  1064.     incr data(hdrPixels) $data(charWidth)
  1065.     switch $alignment {
  1066.         left {
  1067.         lappend tabs $data(hdrPixels) left
  1068.         incr data(hdrPixels) $pixels
  1069.         }
  1070.         right {
  1071.         incr data(hdrPixels) $pixels
  1072.         lappend tabs $data(hdrPixels) right
  1073.         }
  1074.         center {
  1075.         lappend tabs [expr {$data(hdrPixels) + $pixels/2}] center
  1076.         incr data(hdrPixels) $pixels
  1077.         }
  1078.     }
  1079.     incr data(hdrPixels) $data(charWidth)
  1080.     lappend tabs $data(hdrPixels) left
  1081.  
  1082.     incr col
  1083.     }
  1084.     place $data(hdrLbl) -x $data(hdrPixels)
  1085.  
  1086.     #
  1087.     # Apply the value of tabs to the body text widget
  1088.     #
  1089.     $data(body) configure -tabs $tabs
  1090.  
  1091.     #
  1092.     # Adjust the width and height of the frames data(hdrTxtFr) and data(hdr)
  1093.     #
  1094.     $data(hdrTxtFr) configure -width $data(hdrPixels)
  1095.     if {$data(-width) <= 0} {
  1096.     if {$stretchCols} {
  1097.         $data(hdr) configure -width $data(hdrPixels)
  1098.         $data(lb) configure -width \
  1099.               [expr {$data(hdrPixels) / $data(charWidth)}]
  1100.     }
  1101.     } else {
  1102.     $data(hdr) configure -width 0
  1103.     }
  1104.     adjustHeaderHeight $win
  1105.  
  1106.     #
  1107.     # Stretch the stretchable columns if requested
  1108.     #
  1109.     if {$stretchCols} {
  1110.     stretchColumnsWhenIdle $win
  1111.     }
  1112. }
  1113.  
  1114. #------------------------------------------------------------------------------
  1115. # tablelist::adjustLabel
  1116. #
  1117. # Applies some configuration options to the col'th label of the tablelist
  1118. # widget win as well as to the label's children (if any), and places the
  1119. # children.
  1120. #------------------------------------------------------------------------------
  1121. proc tablelist::adjustLabel {win col pixels alignment} {
  1122.     upvar ::tablelist::ns${win}::data data
  1123.  
  1124.     #
  1125.     # Apply some configuration options to the label and its children (if any)
  1126.     #
  1127.     set w $data(hdrTxtFrLbl)$col
  1128.     switch $alignment {
  1129.     left    { set anchor w }
  1130.     right    { set anchor e }
  1131.     center    { set anchor center }
  1132.     }
  1133.     set padX [expr {$data(charWidth) - [$w cget -borderwidth]}]
  1134.     $w configure -anchor $anchor -justify $alignment -padx $padX
  1135.     if {[info exists data($col-labelimage)]} {
  1136.     set imageWidth [image width $data($col-labelimage)]
  1137.     if {[string compare $alignment right] == 0} {
  1138.         $w.il configure -anchor e -width 0
  1139.     } else {
  1140.         $w.il configure -anchor w -width 0
  1141.     }
  1142.     $w.tl configure -anchor $anchor -justify $alignment
  1143.     } else {
  1144.     set imageWidth 0
  1145.     }
  1146.  
  1147.     #
  1148.     # Make room for the canvas displaying an an up- or down-arrow if needed
  1149.     #
  1150.     set title [lindex $data(-columns) [expr {3*$col + 1}]]
  1151.     set labelFont [$w cget -font]
  1152.     if {$col == $data(arrowCol)} {
  1153.     if {[font metrics $labelFont -displayof $w -fixed]} {
  1154.         set spaces "   "                ;# 3 spaces
  1155.     } else {
  1156.         set spaces "     "                ;# 5 spaces
  1157.     }
  1158.     } else {
  1159.     set spaces ""
  1160.     }
  1161.     set spacePixels [font measure $labelFont -displayof $w $spaces]
  1162.  
  1163.     if {$pixels == 0} {                ;# convention: dynamic width
  1164.     #
  1165.     # Set the label text
  1166.     #
  1167.     if {$imageWidth == 0} {                ;# no image
  1168.         if {[string compare $title ""] == 0} {
  1169.         set text $spaces
  1170.         } else {
  1171.         set lines {}
  1172.         foreach line [split $title \n] {
  1173.             if {[string compare $alignment right] == 0} {
  1174.             lappend lines $spaces$line
  1175.             } else {
  1176.             lappend lines $line$spaces
  1177.             }
  1178.         }
  1179.         set text [join $lines \n]
  1180.         }
  1181.         $w configure -text $text
  1182.     } elseif {[string compare $title ""] == 0} {    ;# image w/o text
  1183.         $w configure -text ""
  1184.         set text ""
  1185.         $w.il configure -width [expr {$imageWidth + $spacePixels}]
  1186.     } else {                    ;# both image and text
  1187.         $w configure -text ""
  1188.         set lines {}
  1189.         foreach line [split $title \n] {
  1190.         if {[string compare $alignment right] == 0} {
  1191.             lappend lines $spaces$line
  1192.         } else {
  1193.             lappend lines $line$spaces
  1194.         }
  1195.         }
  1196.         set text [join $lines \n]
  1197.         $w.tl configure -text $text
  1198.         set colFont [lindex $data(colFontList) $col]
  1199.         set gap [font measure $colFont -displayof $win " "]
  1200.         $w.il configure -width [expr {$imageWidth + $gap}]
  1201.     }
  1202.     } else {
  1203.     #
  1204.     # Clip each line of title according to pixels and alignment
  1205.     #
  1206.     set lessPixels [expr {$pixels - $spacePixels}]
  1207.     if {$imageWidth == 0} {                ;# no image
  1208.         if {[string compare $title ""] == 0} {
  1209.         set text $spaces
  1210.         } else {
  1211.         set lines {}
  1212.         foreach line [split $title \n] {
  1213.             set line [strRangeExt $win $line $labelFont \
  1214.                   $lessPixels $alignment $data(-snipstring)]
  1215.             if {[string compare $alignment right] == 0} {
  1216.             lappend lines $spaces$line
  1217.             } else {
  1218.             lappend lines $line$spaces
  1219.             }
  1220.         }
  1221.         set text [join $lines \n]
  1222.         }
  1223.         $w configure -text $text
  1224.     } elseif {[string compare $title ""] == 0} {    ;# image w/o text
  1225.         $w configure -text ""
  1226.         set text ""
  1227.         if {$imageWidth <= $lessPixels} {
  1228.         $w.il configure -width [expr {$imageWidth + $spacePixels}]
  1229.         } else {
  1230.         set imageWidth 0        ;# can't display the image
  1231.         }
  1232.     } else {                    ;# both image and text
  1233.         $w configure -text ""
  1234.         set colFont [lindex $data(colFontList) $col]
  1235.         set gap [font measure $colFont -displayof $win " "]
  1236.         if {$imageWidth + $gap <= $lessPixels} {
  1237.         incr lessPixels -[expr {$imageWidth + $gap}]
  1238.         set lines {}
  1239.         foreach line [split $title \n] {
  1240.             set line [strRangeExt $win $line $labelFont \
  1241.                   $lessPixels $alignment $data(-snipstring)]
  1242.             if {[string compare $alignment right] == 0} {
  1243.             lappend lines $spaces$line
  1244.             } else {
  1245.             lappend lines $line$spaces
  1246.             }
  1247.         }
  1248.         set text [join $lines \n]
  1249.         $w.tl configure -text $text
  1250.         $w.il configure -width [expr {$imageWidth + $gap}]
  1251.         } elseif {$imageWidth <= $lessPixels} {    
  1252.         set text ""            ;# can't display the text
  1253.         $w.il configure -width [expr {$imageWidth + $spacePixels}]
  1254.         } else {
  1255.         set imageWidth 0        ;# can't display the image
  1256.         set text ""            ;# can't display the text
  1257.         }
  1258.     }
  1259.     }
  1260.  
  1261.     #
  1262.     # Place the label's children (if any)
  1263.     #
  1264.     if {$imageWidth == 0} {
  1265.     if {[info exists data($col-labelimage)]} {
  1266.         place forget $w.il
  1267.         place forget $w.tl
  1268.     }
  1269.     } else {
  1270.     if {[string compare $text ""] == 0} {
  1271.         place forget $w.tl
  1272.     }
  1273.  
  1274.     switch $alignment {
  1275.         left {
  1276.         place $w.il -anchor nw -relx 0.0 -x $padX -relheight 1.0
  1277.         if {[string compare $text ""] != 0} {
  1278.             set textX [expr {$padX + [winfo reqwidth $w.il]}]
  1279.             place $w.tl -anchor nw -relx 0.0 -x $textX -relheight 1.0
  1280.         }
  1281.         }
  1282.  
  1283.         right {
  1284.         place $w.il -anchor ne -relx 1.0 -x -$padX -relheight 1.0
  1285.         if {[string compare $text ""] != 0} {
  1286.             set textX [expr {-$padX - [winfo reqwidth $w.il]}]
  1287.             place $w.tl -anchor ne -relx 1.0 -x $textX -relheight 1.0
  1288.         }
  1289.         }
  1290.  
  1291.         center {
  1292.         if {[string compare $text ""] == 0} {
  1293.             place $w.il -anchor n -relx 0.5 -x 0 -relheight 1.0
  1294.         } else {
  1295.             set halfWidth [expr {([winfo reqwidth $w.il] + \
  1296.                       [winfo reqwidth $w.tl]) / 2}]
  1297.             place $w.il -anchor nw -relx 0.5 -x -$halfWidth \
  1298.                 -relheight 1.0
  1299.             place $w.tl -anchor ne -relx 0.5 -x $halfWidth \
  1300.                 -relheight 1.0
  1301.         }
  1302.         }
  1303.     }
  1304.     }
  1305. }
  1306.  
  1307. #------------------------------------------------------------------------------
  1308. # tablelist::computeColWidth
  1309. #
  1310. # Computes the width of the col'th column of the tablelist widget win to be just
  1311. # large enough to hold all the elements of the column (including its label).
  1312. #------------------------------------------------------------------------------
  1313. proc tablelist::computeColWidth {win col} {
  1314.     upvar ::tablelist::ns${win}::data data
  1315.  
  1316.     set fmtCmdFlag [info exists data($col-formatcommand)]
  1317.     set colFont [lindex $data(colFontList) $col]
  1318.  
  1319.     set data($col-elemWidth) 0
  1320.     set data($col-widestCount) 0
  1321.  
  1322.     #
  1323.     # Column elements
  1324.     #
  1325.     foreach item $data(itemList) {
  1326.     if {$col >= [llength $item] - 1} {
  1327.         continue
  1328.     }
  1329.  
  1330.     set text [lindex $item $col]
  1331.     if {$fmtCmdFlag} {
  1332.         set text [uplevel #0 $data($col-formatcommand) [list $text]]
  1333.     }
  1334.     set text [strToDispStr $text]
  1335.     set key [lindex $item end]
  1336.     if {[info exists data($key-$col-image)]} {
  1337.         set imageWidth [image width $data($key-$col-image)]
  1338.     } else {
  1339.         set imageWidth 0
  1340.     }
  1341.     if {[info exists data($key-$col-font)]} {
  1342.         set cellFont $data($key-$col-font)
  1343.     } elseif {[info exists data($key-font)]} {
  1344.         set cellFont $data($key-font)
  1345.     } else {
  1346.         set cellFont $colFont
  1347.     }
  1348.     adjustElem $win text imageWidth $cellFont 0 left ""
  1349.     set textWidth [font measure $cellFont -displayof $win $text]
  1350.     set elemWidth [expr {$imageWidth + $textWidth}]
  1351.     if {$elemWidth == $data($col-elemWidth)} {
  1352.         incr data($col-widestCount)
  1353.     } elseif {$elemWidth > $data($col-elemWidth)} {
  1354.         set data($col-elemWidth) $elemWidth
  1355.         set data($col-widestCount) 1
  1356.     }
  1357.     }
  1358.     set data($col-reqPixels) $data($col-elemWidth)
  1359.  
  1360.     #
  1361.     # Column label
  1362.     #
  1363.     computeLabelWidth $win $col
  1364. }
  1365.  
  1366. #------------------------------------------------------------------------------
  1367. # tablelist::computeLabelWidth
  1368. #
  1369. # Computes the width of the col'th label of the tablelist widget win and
  1370. # adjusts the column's width accordingly.
  1371. #------------------------------------------------------------------------------
  1372. proc tablelist::computeLabelWidth {win col} {
  1373.     upvar ::tablelist::ns${win}::data data
  1374.  
  1375.     set w $data(hdrTxtFrLbl)$col
  1376.     if {[info exists data($col-labelimage)]} {
  1377.     set title [lindex $data(-columns) [expr {3*$col + 1}]]
  1378.     if {[string compare $title ""] == 0} {        ;# image w/o text
  1379.         set netLabelWidth [winfo reqwidth $w.il]
  1380.     } else {                    ;# both image and text
  1381.         set netLabelWidth [expr {[winfo reqwidth $w.il] +
  1382.                      [winfo reqwidth $w.tl]}]
  1383.     }
  1384.     } else {                        ;# no image
  1385.     set netLabelWidth [expr {[winfo reqwidth $w] - 2*$data(charWidth)}]
  1386.     }
  1387.  
  1388.     if {$netLabelWidth < $data($col-elemWidth)} {
  1389.     set data($col-reqPixels) $data($col-elemWidth)
  1390.     } else {
  1391.     set data($col-reqPixels) $netLabelWidth
  1392.     }
  1393. }
  1394.  
  1395. #------------------------------------------------------------------------------
  1396. # tablelist::adjustHeaderHeight
  1397. #
  1398. # Sets the height of the header frame of the tablelist widget win to the max.
  1399. # height of its children.
  1400. #------------------------------------------------------------------------------
  1401. proc tablelist::adjustHeaderHeight win {
  1402.     upvar ::tablelist::ns${win}::data data
  1403.  
  1404.     #
  1405.     # Compute the max. label height
  1406.     #
  1407.     set maxLabelHeight [winfo reqheight $data(hdrLbl)]
  1408.     set children [winfo children $data(hdrTxtFr)]
  1409.     foreach w [lrange [lsort $children] 1 end] {
  1410.     if {[string compare [winfo manager $w] ""] == 0} {
  1411.         continue
  1412.     }
  1413.  
  1414.     set reqHeight [winfo reqheight $w]
  1415.     if {$reqHeight > $maxLabelHeight} {
  1416.         set maxLabelHeight $reqHeight
  1417.     }
  1418.  
  1419.     foreach c [winfo children $w] {
  1420.         if {[string compare [winfo manager $c] ""] == 0} {
  1421.         continue
  1422.         }
  1423.  
  1424.         set reqHeight \
  1425.         [expr {[winfo reqheight $c] + 2*[$w cget -borderwidth]}]
  1426.         if {$reqHeight > $maxLabelHeight} {
  1427.         set maxLabelHeight $reqHeight
  1428.         }
  1429.     }
  1430.     }
  1431.  
  1432.     #
  1433.     # Set the height of the header frame and adjust the separators
  1434.     #
  1435.     $data(hdrTxtFr) configure -height $maxLabelHeight
  1436.     if {$data(-showlabels)} {
  1437.     $data(hdr) configure -height $maxLabelHeight
  1438.     } else {
  1439.     $data(hdr) configure -height 1
  1440.     }
  1441.     adjustSepsWhenIdle $win
  1442. }
  1443.  
  1444. #------------------------------------------------------------------------------
  1445. # tablelist::stretchColumnsWhenIdle
  1446. #
  1447. # Arranges for the stretchable columns of the tablelist widget win to be
  1448. # stretched at idle time.
  1449. #------------------------------------------------------------------------------
  1450. proc tablelist::stretchColumnsWhenIdle win {
  1451.     upvar ::tablelist::ns${win}::data data
  1452.  
  1453.     if {[info exists data(stretchId)]} {
  1454.     return ""
  1455.     }
  1456.  
  1457.     set data(stretchId) [after idle [list tablelist::stretchColumns $win -1]]
  1458. }
  1459.  
  1460. #------------------------------------------------------------------------------
  1461. # tablelist::stretchColumns
  1462. #
  1463. # Stretches the stretchable columns to fill the tablelist window win
  1464. # horizontally.  The colOfFixedDelta argument specifies the column for which
  1465. # the stretching is to be made using a precomputed amount of pixels.
  1466. #------------------------------------------------------------------------------
  1467. proc tablelist::stretchColumns {win colOfFixedDelta} {
  1468.     upvar ::tablelist::ns${win}::data data
  1469.  
  1470.     if {[info exists data(stretchId)]} {
  1471.     after cancel data(stretchId)
  1472.     unset data(stretchId)
  1473.     }
  1474.  
  1475.     set forceAdjust $data(forceAdjust)
  1476.     set data(forceAdjust) 0
  1477.  
  1478.     if {$data(hdrPixels) == 0 || $data(-width) <= 0} {
  1479.     return ""
  1480.     }
  1481.  
  1482.     #
  1483.     # Get the list data(stretchableCols) of the
  1484.     # numerical indices of the stretchable columns
  1485.     #
  1486.     set data(stretchableCols) {}
  1487.     if {[string first $data(-stretch) all] == 0} {
  1488.     for {set col 0} {$col < $data(colCount)} {incr col} {
  1489.         lappend data(stretchableCols) $col
  1490.     }
  1491.     } else {
  1492.     foreach col $data(-stretch) {
  1493.         lappend data(stretchableCols) [colIndex $win $col 0]
  1494.     }
  1495.     }
  1496.  
  1497.     #
  1498.     # Compute the total number data(delta) of pixels by which the
  1499.     # columns are to be stretched and the total amount
  1500.     # data(stretchablePixels) of stretchable column widths in pixels
  1501.     #
  1502.     set data(delta) [winfo width $data(hdr)]
  1503.     set data(stretchablePixels) 0
  1504.     set lastColToStretch -1
  1505.     set col 0
  1506.     foreach {pixels alignment} $data(colList) {
  1507.     if {$data($col-hide)} {
  1508.         incr col
  1509.         continue
  1510.     }
  1511.  
  1512.     if {$pixels == 0} {            ;# convention: dynamic width
  1513.         set pixels $data($col-reqPixels)
  1514.         if {$data($col-maxPixels) > 0 && $pixels > $data($col-maxPixels)} {
  1515.         set pixels $data($col-maxPixels)
  1516.         }
  1517.     }
  1518.     incr data(delta) -[expr {$pixels + 2*$data(charWidth)}]
  1519.     if {[lsearch -exact $data(stretchableCols) $col] >= 0} {
  1520.         incr data(stretchablePixels) $pixels
  1521.         set lastColToStretch $col
  1522.     }
  1523.  
  1524.     incr col
  1525.     }
  1526.     if {$data(delta) < 0} {
  1527.     set delta 0
  1528.     } else {
  1529.     set delta $data(delta)
  1530.     }
  1531.     if {$data(stretchablePixels) == 0 && !$forceAdjust} {
  1532.     return ""
  1533.     }
  1534.  
  1535.     #
  1536.     # Distribute the value of delta to the stretchable
  1537.     # columns, proportionally to their widths in pixels
  1538.     #
  1539.     set rest $delta
  1540.     set col 0
  1541.     foreach {pixels alignment} $data(colList) {
  1542.     if {$data($col-hide) ||
  1543.         [lsearch -exact $data(stretchableCols) $col] < 0} {
  1544.         set data($col-delta) 0
  1545.     } else {
  1546.         set oldDelta $data($col-delta)
  1547.         if {$pixels == 0} {            ;# convention: dynamic width
  1548.         set pixels $data($col-reqPixels)
  1549.         if {$data($col-maxPixels) > 0 &&
  1550.             $pixels > $data($col-maxPixels)} {
  1551.             set pixels $data($col-maxPixels)
  1552.             set dynamic 0
  1553.         } else {
  1554.             set dynamic 1
  1555.         }
  1556.         } else {
  1557.         set dynamic 0
  1558.         }
  1559.         if {$data(stretchablePixels) == 0} {
  1560.         set data($col-delta) 0
  1561.         } else {
  1562.         if {$col != $colOfFixedDelta} {
  1563.             set data($col-delta) \
  1564.             [expr {$delta*$pixels/$data(stretchablePixels)}]
  1565.         }
  1566.         incr rest -$data($col-delta)
  1567.         }
  1568.         if {$col == $lastColToStretch} {
  1569.         incr data($col-delta) $rest
  1570.         }
  1571.         if {!$dynamic && $data($col-delta) != $oldDelta} {
  1572.         redisplayWhenIdle $win
  1573.         }
  1574.     }
  1575.  
  1576.     incr col
  1577.     }
  1578.  
  1579.     #
  1580.     # Adjust the columns
  1581.     #
  1582.     adjustColumns $win {} 0
  1583.     update idletasks
  1584. }
  1585.  
  1586. #------------------------------------------------------------------------------
  1587. # tablelist::redisplayWhenIdle
  1588. #
  1589. # Arranges for the items of the tablelist widget win to be redisplayed at idle
  1590. # time.
  1591. #------------------------------------------------------------------------------
  1592. proc tablelist::redisplayWhenIdle win {
  1593.     upvar ::tablelist::ns${win}::data data
  1594.  
  1595.     if {[info exists data(redispId)] || $data(itemCount) == 0} {
  1596.     return ""
  1597.     }
  1598.  
  1599.     set data(redispId) [after idle [list tablelist::redisplay $win]]
  1600. }
  1601.  
  1602. #------------------------------------------------------------------------------
  1603. # tablelist::redisplay
  1604. #
  1605. # Redisplays the items of the tablelist widget win.
  1606. #------------------------------------------------------------------------------
  1607. proc tablelist::redisplay win {
  1608.     upvar ::tablelist::ns${win}::data data
  1609.  
  1610.     if {[info exists data(redispId)]} {
  1611.     after cancel $data(redispId)
  1612.     unset data(redispId)
  1613.     }
  1614.  
  1615.     #
  1616.     # Save some data of the edit window if present
  1617.     #
  1618.     if {[set editCol $data(editCol)] >= 0} {
  1619.     set editRow $data(editRow)
  1620.     saveEditData $win
  1621.     }
  1622.  
  1623.     set w $data(body)
  1624.     set widgetFont $data(-font)
  1625.     set snipStr $data(-snipstring)
  1626.     set isSimple [expr {$data(tagCount) == 0 && $data(imgCount) == 0 &&
  1627.             !$data(hasColTags)}]
  1628.     set newItemList {}
  1629.     set idx 0
  1630.     set line 1
  1631.     foreach item $data(itemList) {
  1632.     #
  1633.     # Check whether the line is selected
  1634.     #
  1635.     set tagNames [$w tag names $line.0]
  1636.     if {[lsearch -exact $tagNames select] >= 0} {
  1637.         set selected 1
  1638.     } else {
  1639.         set selected 0
  1640.     }
  1641.  
  1642.     #
  1643.     # Empty the line, clip the elements if necessary,
  1644.     # and insert them with the corresponding tags
  1645.     #
  1646.     $w delete $line.0 $line.end
  1647.     set keyIdx [expr {[llength $item] - 1}]
  1648.     set key [lindex $item end]
  1649.     set newItem {}
  1650.     set col 0
  1651.     if {$isSimple} {
  1652.         set insertStr ""
  1653.         foreach fmtCmdFlag $data(fmtCmdFlagList) \
  1654.             {pixels alignment} $data(colList) {
  1655.         if {$col < $keyIdx} {
  1656.             set text [lindex $item $col]
  1657.         } else {
  1658.             set text ""
  1659.         }
  1660.         lappend newItem $text
  1661.  
  1662.         if {$data($col-hide)} {
  1663.             incr col
  1664.             continue
  1665.         }
  1666.  
  1667.         #
  1668.         # Clip the element if necessary
  1669.         #
  1670.         if {$fmtCmdFlag} {
  1671.             set text [uplevel #0 $data($col-formatcommand) [list $text]]
  1672.         }
  1673.         set text [strToDispStr $text]
  1674.         if {$pixels == 0} {        ;# convention: dynamic width
  1675.             if {$data($col-maxPixels) > 0 &&
  1676.             $data($col-reqPixels) > $data($col-maxPixels)} {
  1677.             set pixels $data($col-maxPixels)
  1678.             }
  1679.         }
  1680.         if {$pixels != 0} {
  1681.             incr pixels $data($col-delta)
  1682.             set text [strRangeExt $win $text $widgetFont \
  1683.                   $pixels $alignment $snipStr]
  1684.         }
  1685.  
  1686.         append insertStr \t$text\t
  1687.         incr col
  1688.         }
  1689.  
  1690.         #
  1691.         # Insert the item into the body text widget
  1692.         #
  1693.         $w insert $line.0 $insertStr
  1694.  
  1695.     }  else {
  1696.         array set tagData [array get data $key*-\[bf\]*]    ;# for speed
  1697.  
  1698.         set rowTags [array names tagData $key-\[bf\]*]
  1699.         foreach colFont $data(colFontList) \
  1700.             colTags $data(colTagsList) \
  1701.             fmtCmdFlag $data(fmtCmdFlagList) \
  1702.             {pixels alignment} $data(colList) {
  1703.         if {$col < $keyIdx} {
  1704.             set text [lindex $item $col]
  1705.         } else {
  1706.             set text ""
  1707.         }
  1708.         lappend newItem $text
  1709.  
  1710.         if {$data($col-hide)} {
  1711.             incr col
  1712.             continue
  1713.         }
  1714.  
  1715.         #
  1716.         # Adjust the cell text and the image width
  1717.         #
  1718.         if {$fmtCmdFlag} {
  1719.             set text [uplevel #0 $data($col-formatcommand) [list $text]]
  1720.         }
  1721.         set text [strToDispStr $text]
  1722.         if {[info exists data($key-$col-image)]} {
  1723.             set image $data($key-$col-image)
  1724.             set imageWidth [image width $image]
  1725.         } else {
  1726.             set image ""
  1727.             set imageWidth 0
  1728.         }
  1729.         if {[info exists data($key-$col-font)]} {
  1730.             set cellFont $data($key-$col-font)
  1731.         } elseif {[info exists data($key-font)]} {
  1732.             set cellFont $data($key-font)
  1733.         } else {
  1734.             set cellFont $colFont
  1735.         }
  1736.         if {$pixels == 0} {        ;# convention: dynamic width
  1737.             if {$data($col-maxPixels) > 0 &&
  1738.             $data($col-reqPixels) > $data($col-maxPixels)} {
  1739.             set pixels $data($col-maxPixels)
  1740.             }
  1741.         }
  1742.         if {$pixels != 0} {
  1743.             incr pixels $data($col-delta)
  1744.         }
  1745.         adjustElem $win text imageWidth $cellFont \
  1746.                $pixels $alignment $snipStr
  1747.  
  1748.         #
  1749.         # Insert the text and the image
  1750.         #
  1751.         set cellTags [array names tagData $key-$col-\[bf\]*]
  1752.         set tagNames [concat $colTags $rowTags $cellTags]
  1753.         if {$imageWidth == 0} {
  1754.             $w insert $line.end \t$text\t $tagNames
  1755.         } else {
  1756.             $w insert $line.end \t\t $tagNames
  1757.             insertElem $w $line.end-1c $text $image $imageWidth \
  1758.                    $alignment
  1759.         }
  1760.  
  1761.         incr col
  1762.         }
  1763.  
  1764.         unset tagData
  1765.     }
  1766.     lappend newItem $key
  1767.     lappend newItemList $newItem
  1768.  
  1769.     #
  1770.     # Select the item if it was selected before
  1771.     #
  1772.     if {$selected} {
  1773.         selectionSubCmd $win set $idx $idx
  1774.     }
  1775.  
  1776.     incr idx
  1777.     incr line
  1778.     }
  1779.  
  1780.     set data(itemList) $newItemList
  1781.  
  1782.     #
  1783.     # Restore the stripes in the body text widget
  1784.     #
  1785.     makeStripes $win
  1786.  
  1787.     #
  1788.     # Restore the edit window if it was present before
  1789.     #
  1790.     if {$editCol >= 0} {
  1791.     editcellSubCmd $win $editRow $editCol 1
  1792.     }
  1793. }
  1794.  
  1795. #------------------------------------------------------------------------------
  1796. # tablelist::makeStripesWhenIdle
  1797. #
  1798. # Arranges for the stripes in the body of the tablelist widget win to be
  1799. # redrawn at idle time.
  1800. #------------------------------------------------------------------------------
  1801. proc tablelist::makeStripesWhenIdle win {
  1802.     upvar ::tablelist::ns${win}::data data
  1803.  
  1804.     if {[info exists data(stripesId)] || $data(itemCount) == 0} {
  1805.     return ""
  1806.     }
  1807.  
  1808.     set data(stripesId) [after idle [list tablelist::makeStripes $win]]
  1809. }
  1810.  
  1811. #------------------------------------------------------------------------------
  1812. # tablelist::makeStripes
  1813. #
  1814. # Redraws the stripes in the body of the tablelist widget win.
  1815. #------------------------------------------------------------------------------
  1816. proc tablelist::makeStripes win {
  1817.     upvar ::tablelist::ns${win}::data data
  1818.  
  1819.     if {[info exists data(stripesId)]} {
  1820.     after cancel $data(stripesId)
  1821.     unset data(stripesId)
  1822.     }
  1823.  
  1824.     set w $data(body)
  1825.     $w tag remove stripe 1.0 end
  1826.     if {[string compare $data(-stripebackground) ""] == 0 &&
  1827.     [string compare $data(-stripeforeground) ""] == 0} {
  1828.     return ""
  1829.     }
  1830.  
  1831.     set step [expr {2*$data(-stripeheight)}]
  1832.     for {set n [expr {$data(-stripeheight) + 1}]} {$n <= $step} {incr n} {
  1833.     for {set line $n} {$line <= $data(itemCount)} {incr line $step} {
  1834.         $w tag add stripe $line.0 $line.end
  1835.     }
  1836.     }
  1837. }
  1838.  
  1839. #------------------------------------------------------------------------------
  1840. # tablelist::synchronize
  1841. #
  1842. # This procedure is invoked either as an idle callback after the list variable
  1843. # associated with the tablelist widget win was written, or directly, upon
  1844. # execution of some widget commands.  It makes sure that the content of the
  1845. # widget is synchronized with the value of the list variable.
  1846. #------------------------------------------------------------------------------
  1847. proc tablelist::synchronize win {
  1848.     upvar ::tablelist::ns${win}::data data
  1849.  
  1850.     #
  1851.     # Nothing to do if the list variable was not written
  1852.     #
  1853.     if {![info exists data(syncId)]} {
  1854.     return ""
  1855.     }
  1856.  
  1857.     #
  1858.     # Here we are in the case that the procedure was scheduled for
  1859.     # execution at idle time.  However, it might have been invoked
  1860.     # directly, before the idle time occured; in this case we should
  1861.     # cancel the execution of the previously scheduled idle callback.
  1862.     #
  1863.     after cancel $data(syncId)    ;# no harm if data(syncId) is no longer valid
  1864.     unset data(syncId)
  1865.  
  1866.     upvar #0 $data(-listvariable) var
  1867.     set newCount [llength $var]
  1868.     if {$newCount < $data(itemCount)} {
  1869.     #
  1870.     # Delete the items with indices >= newCount from the widget
  1871.     #
  1872.     set updateCount $newCount
  1873.     deleteRows $win $newCount $data(lastRow) 0
  1874.     } elseif {$newCount > $data(itemCount)} {
  1875.     #
  1876.     # Insert the items of var with indices
  1877.     # >= data(itemCount) into the widget
  1878.     #
  1879.     set updateCount $data(itemCount)
  1880.     insertSubCmd $win $data(itemCount) \
  1881.              [lrange $var $data(itemCount) end] 0
  1882.     } else {
  1883.     set updateCount $newCount
  1884.     }
  1885.  
  1886.     #
  1887.     # Update the first updateCount items of the internal list
  1888.     #
  1889.     set itemsChanged 0
  1890.     for {set idx 0} {$idx < $updateCount} {incr idx} {
  1891.     set oldItem [lindex $data(itemList) $idx]
  1892.     set newItem [adjustItem [lindex $var $idx] $data(colCount)]
  1893.     lappend newItem [lindex $oldItem end]
  1894.  
  1895.     if {[string compare $oldItem $newItem] != 0} {
  1896.         set data(itemList) [lreplace $data(itemList) $idx $idx $newItem]
  1897.         set itemsChanged 1
  1898.     }
  1899.     }
  1900.  
  1901.     #
  1902.     # If necessary, adjust the columns and make sure
  1903.     # that the items will be redisplayed at idle time
  1904.     #
  1905.     if {$itemsChanged} {
  1906.     adjustColumns $win allCols 1
  1907.     redisplayWhenIdle $win
  1908.     }
  1909. }
  1910.  
  1911. #------------------------------------------------------------------------------
  1912. # tablelist::configLabel
  1913. #
  1914. # This procedure configures the label widget w according to the options and
  1915. # their values given in args.  It is needed for label widgets with children,
  1916. # managed by the place geometry manager, because - strangely enough - by just
  1917. # configuring the label causes its children to become invisible on Windows (but
  1918. # not on UNIX).  The procedure solves this problem by using a trick: after
  1919. # configuring the label, it applies a constant configuration value to its
  1920. # children, which makes them visible again.
  1921. #------------------------------------------------------------------------------
  1922. proc tablelist::configLabel {w args} {
  1923.     eval [list $w configure] $args
  1924.  
  1925.     foreach c [winfo children $w] {
  1926.     $c configure -borderwidth 0
  1927.     }
  1928. }
  1929.  
  1930. #------------------------------------------------------------------------------
  1931. # tablelist::create3DArrows
  1932. #
  1933. # Creates the items to be used later for drawing two up- or down-arrows with
  1934. # sunken relief and 3-D borders in the canvas w.
  1935. #------------------------------------------------------------------------------
  1936. proc tablelist::create3DArrows w {
  1937.     foreach state {normal disabled} {
  1938.     $w create polygon 0 0 0 0 0 0 -tags ${state}Triangle
  1939.     $w create line    0 0 0 0     -tags ${state}DarkLine
  1940.     $w create line    0 0 0 0     -tags ${state}LightLine
  1941.     }
  1942. }
  1943.  
  1944. #------------------------------------------------------------------------------
  1945. # tablelist::configCanvas
  1946. #
  1947. # Sets the background, width, and height of the canvas displaying an up- or
  1948. # down-arrow, fills the two arrows contained in the canvas, and saves its width
  1949. # in data(arrowWidth).
  1950. #------------------------------------------------------------------------------
  1951. proc tablelist::configCanvas win {
  1952.     upvar ::tablelist::ns${win}::data data
  1953.  
  1954.     set w $data(hdrTxtFrLbl)$data(arrowCol)
  1955.     set labelBg [$w cget -background]
  1956.     set labelFont [$w cget -font]
  1957.     if {[font metrics $labelFont -displayof $w -fixed]} {
  1958.     set spaces " "
  1959.     } else {
  1960.     set spaces "  "
  1961.     }
  1962.  
  1963.     set size [expr {[font measure $labelFont -displayof $w $spaces] + 2}]
  1964.     if {$size % 2 == 0} {
  1965.     incr size
  1966.     }
  1967.  
  1968.     set w $data(hdrTxtFrCanv)
  1969.     $w configure -background $labelBg -height $size -width $size
  1970.     fillArrow $w normal   $data(-arrowcolor)
  1971.     fillArrow $w disabled $data(-arrowdisabledcolor)
  1972.  
  1973.     set data(arrowWidth) $size
  1974. }
  1975.  
  1976. #------------------------------------------------------------------------------
  1977. # tablelist::drawArrows
  1978. #
  1979. # Draws the two arrows contained in the canvas associated with the tablelist
  1980. # widget win.
  1981. #------------------------------------------------------------------------------
  1982. proc tablelist::drawArrows win {
  1983.     upvar ::tablelist::ns${win}::data data
  1984.  
  1985.     switch $data(-incrarrowtype) {
  1986.     up {
  1987.         switch $data(sortOrder) {
  1988.         increasing { set arrowType up }
  1989.         decreasing { set arrowType down }
  1990.         }
  1991.     }
  1992.  
  1993.     down {
  1994.         switch $data(sortOrder) {
  1995.         increasing { set arrowType down }
  1996.         decreasing { set arrowType up }
  1997.         }
  1998.     }
  1999.     }
  2000.  
  2001.     set w $data(hdrTxtFrCanv)
  2002.     set maxX [expr {[$w cget -width] - 1}]
  2003.     set maxY [expr {[$w cget -height] - 1}]
  2004.     set midX [expr {$maxX / 2}]
  2005.  
  2006.     switch $arrowType {
  2007.     up {
  2008.         foreach state {normal disabled} {
  2009.         $w coords ${state}Triangle  0 $maxY $maxX $maxY $midX 0
  2010.         $w coords ${state}DarkLine  $midX 0 0 $maxY
  2011.         $w coords ${state}LightLine 0 $maxY $maxX $maxY $midX 0
  2012.         }
  2013.     }
  2014.  
  2015.     down {
  2016.         foreach state {normal disabled} {
  2017.         $w coords ${state}Triangle  $maxX 0 0 0 $midX $maxY
  2018.         $w coords ${state}DarkLine  $maxX 0 0 0 $midX $maxY
  2019.         $w coords ${state}LightLine $midX $maxY $maxX 0
  2020.         }
  2021.     }
  2022.     }
  2023. }
  2024.  
  2025. #------------------------------------------------------------------------------
  2026. # tablelist::fillArrow
  2027. #
  2028. # Fills one of the two arrows contained in the canvas w with the given color,
  2029. # or with (a slightly darker color than) the background color of the canvas if
  2030. # color is an empty string.  Also fills the arrow's borders with the
  2031. # corresponding 3-D shadow colors.  The state argument specifies the arrow to
  2032. # be processed.  Returns the properly formatted value of color.
  2033. #------------------------------------------------------------------------------
  2034. proc tablelist::fillArrow {w state color} {
  2035.     if {[string compare $color ""] == 0} {
  2036.     set origColor $color
  2037.     set color [$w cget -background]
  2038.  
  2039.     #
  2040.     # To get a better contrast, make the color slightly
  2041.     # darker by cutting 5% from each of its components
  2042.     #
  2043.     set maxIntens [lindex [winfo rgb $w white] 0]
  2044.     set len [string length [format %x $maxIntens]]
  2045.     foreach comp [winfo rgb $w $color] {
  2046.         lappend rgb [expr {95*$comp/100}]
  2047.     }
  2048.     set color [eval format "#%0${len}x%0${len}x%0${len}x" $rgb]
  2049.     }
  2050.  
  2051.     getShadows $w $color darkColor lightColor
  2052.  
  2053.     $w itemconfigure ${state}Triangle  -fill $color
  2054.     $w itemconfigure ${state}DarkLine  -fill $darkColor
  2055.     $w itemconfigure ${state}LightLine -fill $lightColor
  2056.  
  2057.     if {[info exists origColor]} {
  2058.     return $origColor
  2059.     } else {
  2060.     return [$w itemcget ${state}Triangle -fill]
  2061.     }
  2062. }
  2063.  
  2064. #------------------------------------------------------------------------------
  2065. # tablelist::getShadows
  2066. #
  2067. # Computes the shadow colors for a 3-D border from a given (background) color.
  2068. # This is a modified Tcl-counterpart of the function TkpGetShadows() in the
  2069. # Tk distribution file unix/tkUnix3d.c.
  2070. #------------------------------------------------------------------------------
  2071. proc tablelist::getShadows {w color darkColorName lightColorName} {
  2072.     upvar $darkColorName darkColor $lightColorName lightColor
  2073.  
  2074.     set maxIntens [lindex [winfo rgb $w white] 0]
  2075.     set len [string length [format %x $maxIntens]]
  2076.  
  2077.     set rgb [winfo rgb $w $color]
  2078.     foreach {r g b} $rgb {}
  2079.  
  2080.     #
  2081.     # Compute the dark shadow color
  2082.     #
  2083.     if {[string compare $::tk_patchLevel 8.3.1] >= 0 &&
  2084.     $r*0.5*$r + $g*1.0*$g + $b*0.28*$b < $maxIntens*0.05*$maxIntens} {
  2085.     #
  2086.     # The background is already very dark: make the dark
  2087.     # color a little lighter than the background by increasing
  2088.     # each color component 1/4th of the way to $maxIntens
  2089.     #
  2090.     foreach comp $rgb {
  2091.         lappend darkRGB [expr {($maxIntens + 3*$comp)/4}]
  2092.     }
  2093.     } else {
  2094.     #
  2095.     # Compute the dark color by cutting 45% from
  2096.     # each of the background color components.
  2097.     #
  2098.     foreach comp $rgb {
  2099.         lappend darkRGB [expr {55*$comp/100}]
  2100.     }
  2101.     }
  2102.     set darkColor [eval format "#%0${len}x%0${len}x%0${len}x" $darkRGB]
  2103.  
  2104.     #
  2105.     # Compute the light shadow color
  2106.     #
  2107.     if {[string compare $::tk_patchLevel 8.3.1] >= 0 && $g > $maxIntens*0.95} {
  2108.     #
  2109.     # The background is already very bright: make the
  2110.     # light color a little darker than the background
  2111.     # by reducing each color component by 10%
  2112.     #
  2113.     foreach comp $rgb {
  2114.         lappend lightRGB [expr {9*$comp/10}]
  2115.     }
  2116.     } else {
  2117.     #
  2118.     # Compute the light color by boosting each background
  2119.     # color component by 45% or half-way to white, whichever
  2120.     # is greater (the first approach works better for
  2121.     # unsaturated colors, the second for saturated ones)
  2122.     #
  2123.     foreach comp $rgb {
  2124.         set comp1 [expr {145*$comp/100}]
  2125.         if {$comp1 > $maxIntens} {
  2126.         set comp1 $maxIntens
  2127.         }
  2128.         set comp2 [expr {($maxIntens + $comp)/2}]
  2129.         lappend lightRGB [expr {($comp1 > $comp2) ? $comp1 : $comp2}]
  2130.     }
  2131.     }
  2132.     set lightColor [eval format "#%0${len}x%0${len}x%0${len}x" $lightRGB]
  2133. }
  2134.  
  2135. #------------------------------------------------------------------------------
  2136. # tablelist::raiseArrow
  2137. #
  2138. # Raises one of the two arrows contained in the canvas w, according to the
  2139. # state argument.
  2140. #------------------------------------------------------------------------------
  2141. proc tablelist::raiseArrow {w state} {
  2142.     $w raise ${state}Triangle
  2143.     $w raise ${state}DarkLine
  2144.     $w raise ${state}LightLine
  2145. }
  2146.  
  2147. #------------------------------------------------------------------------------
  2148. # tablelist::isCellEditable
  2149. #
  2150. # Checks whether the given cell of the tablelist widget win is editable.
  2151. #------------------------------------------------------------------------------
  2152. proc tablelist::isCellEditable {win row col} {
  2153.     upvar ::tablelist::ns${win}::data data
  2154.  
  2155.     set item [lindex $data(itemList) $row]
  2156.     set key [lindex $item end]
  2157.     if {[info exists data($key-$col-editable)]} {
  2158.     return $data($key-$col-editable)
  2159.     } else {
  2160.     return $data($col-editable)
  2161.     }
  2162. }
  2163.